home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / procUtils.tcl < prev    next >
Encoding:
Text File  |  2000-12-05  |  8.4 KB  |  325 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "procUtils.tcl"
  6.  #                                    created: 2/8/97 {6:18:16 pm} 
  7.  #                                last update: 12/05/2000 {09:19:12 AM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  # 
  16.  # ###################################################################
  17.  ##
  18.  
  19. namespace eval procs {}
  20.  
  21. if {[info tclversion] < 8.0} {
  22.     proc procs::pick {{try_sel 0}} {
  23.     if {$try_sel && [llength [winNames]] && \
  24.         [string length [set sel [getSelect]]]} {
  25.         if {[info procs $sel] == "$sel"} {
  26.         return $sel
  27.         } else {
  28.         return [procs::pick_list $sel]
  29.         }
  30.     } else {
  31.         return [procs::pick_list]
  32.     }
  33.     }
  34.     proc procs::pick_list {{sel ""}} {
  35.     set list [lsort -ignore [info procs]]
  36.     if {[string length $list] > 30000} {
  37.         set len [llength $list]
  38.         set len [expr {$len / 2}]
  39.         set list1 [lrange $list 0 $len]
  40.         lappend list1 "Next Page "
  41.         set list2 {{Previous Page }}
  42.         eval lappend list2 [lrange $list [expr {$len + 1}] end]
  43.     } else {
  44.         set list1 $list
  45.     }
  46.     set tmpList $list1
  47.     while {1} {
  48.         if {[string length $sel] == 0} {
  49.         set name [listpick -p {Func Name:} $tmpList]
  50.         } else {
  51.         set name [listpick -L $sel -p {Func Name:} $tmpList]
  52.         }
  53.         if {$name == "Next Page "} {
  54.         set tmpList $list2
  55.         } elseif {$name == "Previous Page "} {
  56.         set tmpList $list1
  57.  
  58.         } else {
  59.         return $name
  60.         }
  61.     }
  62.     }
  63. } else {
  64.     ## 
  65.      # -------------------------------------------------------------------------
  66.      # 
  67.      # "procs::pick" --
  68.      # 
  69.      # -------------------------------------------------------------------------
  70.      ##
  71.     proc procs::pick {{try_sel 0}} {
  72.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  73.         if {[llength [uplevel \#0 [list info commands $sel]]] && ![catch {info args $sel}]} {
  74.         return $sel
  75.         } 
  76.     } else {
  77.         set sel ""
  78.     }
  79.     set ns ::
  80.     while {1} {
  81.         set procs [lsort -ignore [namespace children $ns]]
  82.         eval lappend procs [lsort -ignore [uplevel \#0 namespace eval $ns [list info procs]]]
  83.         set choice [listpick -L $sel -p "Pick a function or child namespace in '$ns'" $procs]
  84.         if {![regexp {^::} $choice]} {
  85.         if {${ns} == "::"} {
  86.             return "::${choice}"
  87.         } else {
  88.             return "${ns}::${choice}"
  89.         }
  90.         }
  91.         set ns $choice
  92.     }
  93.     }
  94. }
  95.  
  96. proc procs::debug {func {line 0}} {
  97.     new -n "* Debug of $func *" -m Tcl -text \
  98.       "# Edit the proc in place. Use:\r# 'Reload Proc'\
  99.       to activate changes\r# 'Apply Changes' to put these changes into the original file\
  100.       \r[procs::generate $func]" \
  101.       -dirty 0
  102.     if {$line > 0} {
  103.     # Add one for the comment we inserted
  104.     incr line 3
  105.     goto [rowColToPos $line 0]
  106.     select [getPos] [nextLineStart [getPos]]
  107.     }
  108. }
  109.  
  110. proc procs::patchOriginalsFromFile {f {alerts 1} {keepwin ""}} {
  111.     set openWins [winNames -f]
  112.     # get fixed procs
  113.     uplevel \#0 [list source $f]
  114.     # use 'c' to store comments before each proc
  115.     set procs [procs::listInFile $f c]
  116.     # replace all Alpha's originals
  117.     foreach p $procs {
  118.     if {[catch {procs::autoReplace $p 0 1 c}]} {
  119.         # should not happen
  120.         lappend failed $p
  121.     }
  122.     }
  123.     set nowOpen [winNames -f]    
  124.     foreach f [lremove -l $nowOpen $openWins] {
  125.     if {$f != $keepwin} {
  126.         bringToFront $f
  127.         goto [minPos]
  128.         killWindow
  129.     }
  130.     }    
  131.     if {[info exists failed]} {
  132.     userMessage $alerts "Couldn't find: $failed, this is BAD."
  133.     }
  134.     userMessage $alerts "Replaced [llength $procs] procs successfully."
  135. }
  136.  
  137. proc procs::listInFile {f {comments ""}} {
  138.     if {$comments != ""} { upvar $comments c }
  139.     # open the window
  140.     file::openQuietly $f
  141.     # get procs in order
  142.     set pos [minPos]
  143.     set markExpr "^\[ \t\]*proc"
  144.     set procs ""
  145.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  146.     set start [lindex $res 0]
  147.     set end [nextLineStart $start]
  148.     set text [lindex [getText $start $end] 1]
  149.     set pos $end
  150.     lappend procs $text
  151.     set c($text) [getText [procs::getCommentPos $start] $start]
  152.     }
  153.     killWindow
  154.     return $procs
  155. }
  156.  
  157. ## 
  158.  # -------------------------------------------------------------------------
  159.  # 
  160.  # "procs::getCommentPos" --
  161.  # 
  162.  #  'p' should be the start of a proc.  This looks for a comment which
  163.  #  precedes that procedure.  It returns the start of such a comment,
  164.  #  or 'p' if none was found.  Blank lines are not allowed.
  165.  # -------------------------------------------------------------------------
  166.  ##
  167. proc procs::getCommentPos {p} {
  168.     set q [prevLineStart $p]
  169.     while {[pos::compare $p > [minPos]]} {
  170.     set pp [lindex [search -n -s -f 1 -m 0 -r 1 -l $p -- "\[ \t\]*#" $q] 0]
  171.     if {$pp == "" || ([pos::compare $pp != $q])} {
  172.         break
  173.     }
  174.     set p $q
  175.     set q [prevLineStart $q]
  176.     }
  177.     return $p
  178. }
  179.  
  180. proc procs::generate {p} {
  181.     set a "proc $p \{"
  182.     foreach arg [info args $p] {
  183.     if {[info default $p $arg v]} {
  184.         append a "\{[list $arg $v]\} "
  185.     } else {
  186.         append a "$arg "
  187.     }
  188.     }
  189.     set a [string trimright $a]
  190.     append a "\} \{"
  191.     append a [info body $p]
  192.     append a "\}"
  193.     global tcl_platform
  194.     if {$tcl_platform(platform) == "macintosh"} {
  195.     regsub -all "\n" $a "\r" a
  196.     }
  197.     return $a
  198. }
  199.  
  200. proc procs::searchFor {p} {
  201.     set f [procs::find $p]
  202.     if {![string length $f]} {
  203.     global TclmodeVars
  204.     set pwd [pwd]
  205.     if {[info exists TclmodeVars(procSearchPath)]} {
  206.         foreach dir $TclmodeVars(procSearchPath) {
  207.         cd $dir
  208.         set names [grepnames "^\[ \t\]*;?proc [quote::Regfind $p]\[ \t\]" *]
  209.         if {[llength $names]} {
  210.             cd $pwd
  211.             return [lindex $names 0]
  212.         }
  213.         }
  214.     }
  215.     }
  216.     return $f
  217. }
  218.  
  219. proc procs::autoReplace {p {ask 1} {addAfterLast 0} {commentArrayVar ""}} {
  220.     set f [procs::searchFor $p]
  221.  
  222.     if {$f == ""} { set f [win::Current] }
  223.     
  224.     if {$commentArrayVar != ""} { upvar $commentArrayVar c }
  225.     if {[info exists c($p)]} {
  226.     set com $c($p)
  227.     } else {
  228.     set com ""
  229.     }
  230.     
  231.     procs::replace $f $p $ask $addAfterLast $com
  232.     
  233.     if {[winDirty]} {
  234.     saveUnmodified
  235.     }
  236. }
  237.  
  238. proc procs::replace {f p {ask 1} {addAfterLast 0} {commenttext ""}} {
  239.     file::openQuietly $f
  240.     if {[info tclversion] < 8.0} {
  241.     # Alpha can't cope with colons in names
  242.     regsub -all "\\.\\." $p "::" p
  243.     }
  244.  
  245.     if {[string length $commenttext]} {
  246.     set newp "$commenttext[procs::generate $p]"
  247.     } else {
  248.     set newp [procs::generate $p]
  249.     }
  250.     if {[catch {set a [search -s -f 1 -r 1 -m 0 \
  251.       "^\[ \t\]*proc\[ \t\]+[quote::Regfind $p]\[ \t\]" [minPos]]}]} {
  252.     if {!$addAfterLast} {
  253.         if {$ask} {
  254.         alertnote "Failed to find proc"
  255.         }
  256.         error "Failed to find proc"
  257.     } else {
  258.         # we just add it after the last one
  259.         insertText "\r" $newp "\r\r"
  260.         return
  261.     }
  262.     }
  263.     goto [lindex $a 0]
  264.     set entire [procs::findEnclosing [lindex $a 1]]
  265.     if {[string length $commenttext]} {
  266.     set entire [list [procs::getCommentPos [lindex $entire 0]] [lindex $entire 1]]
  267.     }    
  268.     eval select $entire
  269.     if {$newp == [getSelect]} { 
  270.     message "No change"
  271.     return 
  272.     }
  273.     if {$ask} {
  274.     if {![dialog::yesno "Replace this proc?"]} {
  275.         error "Cancelled"
  276.     }
  277.     }
  278.     eval replaceText $entire [list $newp]
  279. }
  280.  
  281. # If the first brace after 'proc' ends the current line, then
  282. # assume the argument was a single arg with no braces.
  283. proc procs::findEnclosing {pos {type "proc"} {detailed 0} {may_move 0}} {
  284.     set start [lindex [search -s -m 0 -r 1 -f 0 "^\[ \t\]*;?($type) " $pos] 0]
  285.  
  286.     lappend res $start
  287.     
  288.     # find the parameter block
  289.     set p1 [lindex [search -s -f 1 "\{" $start] 0]
  290.     set p [matchIt "\{" [pos::math $p1 + 1]]
  291.     if {$detailed} {lappend res $p1 $p}
  292.     if {[string trim [getText $p1 [nextLineStart $p1]]] == "\{"} {
  293.     if {[pos::compare $p < $pos]} {
  294.         error "couldn't get proc"
  295.     } else {
  296.         return [list $start [pos::math $p + 1]]
  297.     }
  298.     }
  299.     # find the body
  300.     set p [lindex [search -s -f 1 "\{" $p] 0]
  301.     if {$detailed} {lappend res $p}
  302.     # this should not fail.  
  303.     set p [matchIt "\{" [pos::math $p + 1]]
  304.     set p [pos::math $p + 1]
  305.     if {[pos::compare $p < $pos] } { error "couldn't get proc" }
  306.     lappend res $p
  307.     return $res
  308. }
  309.  
  310. proc procs::findEnclosingName {pos} {
  311.     set p [lindex [procs::findEnclosing $pos] 0]
  312.     regsub -all "\[ \t\]+" [string trim [getText $p [nextLineStart $p]] "\{ \t\n\r"] " " t
  313.     return [lindex [split $t] 1]
  314. }
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.